home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PsL Monthly 1993 December
/
PSL Monthly Shareware CD-ROM (December 1993).iso
/
prgmming
/
win
/
pascal
/
edi_thd.exe
/
THREADS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-05-30
|
9KB
|
305 lines
Program ThreadsTest;
{$DEFINE FASTDEMO}
{^Insert a space to undefine}
{$R THREADS.RES}
{$C Moveable DemandLoad Discardable}
{
********************************************************************
* Threads test application *
* *
********************************************************************
* Copyright 1992 Robert Salesas, All Rights Reserved *
********************************************************************
* Version: 1.00 Author: Robert Salesas *
* Date: 22-May-1992 Changes: Original *
* *
********************************************************************
}
Uses ThrdAPI,
WinDOS, WinTypes, WinProcs, Strings;
Const
AppName = 'TPW Threads';
AppFile = 'THREADS.EXE';
ClassName = 'Threads';
Var
Wnd : HWnd;
Msg : TMsg;
AllDone : Boolean;
BallProc,
LinePRoc : TFarProc;
{ ***** Utility functions ***** }
Function Min(X, Y: Integer): Integer;
Begin
If (X < Y) Then
Min := X
Else
Min := Y;
End; {Min}
Function Max(X, Y: Integer): Integer;
Begin
If (X > Y) Then
Max := X
Else
Max := Y;
End; {Max}
{ ***** Thread functions *****}
Procedure LineThread(Thread : PThreadRec; Wnd : HWnd; wParam : Word; lParam : LongInt); Export;
Const
Colors : Array [0..6] Of TColorRef = ($00FF0000,
$0000FF00,
$000000FF,
$00FFFF00,
$0000FFFF,
$00FF00FF,
$00C000C0);
Var
DC : HDC;
Rect : TRect;
Pen,
OPen : HPen;
X, Y : Integer;
Col : TColorRef;
Begin
GetClientRect(Wnd, Rect);
X := Random(Rect.Right);
Y := Random(Rect.Bottom);
Col := Colors[Random(7)];
Pen := CreatePen(ps_Solid, 1, Col);
Repeat
DC := GetDC(Wnd);
If (DC = 0) Then
Begin
DeleteObject(Pen);
ExitThread;
End;
OPen := SelectObject(DC, Pen);
GetClientRect(Wnd, Rect);
MoveTo(DC, X, Y);
X := Max(0, Min(Rect.Right, X + Random(91) - 45));
Y := Max(0, Min(Rect.Bottom, Y + Random(91) - 45));
LineTo(DC, X, Y);
SelectObject(DC, OPen);
ReleaseDC(Wnd, DC);
Until (YieldThread = tm_Quit);
DeleteObject(Pen);
ExitThread;
End;
Procedure BallThread(Thread : PThreadRec; Wnd : HWnd; wParam : Word; lParam : LongInt); Export;
Var
DC : HDC;
Rect : TRect;
XDir,
YDir,
X, OX,
Y, OY : Integer;
Ball,
Erase : HIcon;
Begin
X := 0;
Y := 0;
XDir := 10 + (Random(11) - 5);
YDir := 10 + (Random(11) - 5);
Ball := LoadIcon(HInstance, PChar(Random(4) + 100));
Erase := LoadIcon(HInstance, 'EraseBall');
Repeat
DC := GetDC(Wnd);
If (DC = 0) Then
ExitThread;
GetClientRect(Wnd, Rect);
OX := X;
OY := Y;
X := X + XDir;
Y := Y + YDir;
If (X < 0) Then
Begin
X := 0;
XDir := -(XDir - (Random(11) - 5));
YDir := YDir + (Random(11) - 5);
End;
If (X + 32 > Rect.Right) Then
Begin
X := Rect.Right - 32;
XDir := -(XDir - (Random(11) - 5));
YDir := YDir + (Random(11) - 5);
End;
If (Y < 0) Then
Begin
Y := 0;
XDir := XDir - (Random(11) - 5);
YDir := -(YDir + (Random(11) - 5));
End;
If (Y + 32 > Rect.Bottom) Then
Begin
Y := Rect.Bottom - 32;
XDir := XDir + (Random(11) - 5);
YDir := -(YDir + (Random(11) - 5));
End;
If (XDir <= 0) And (XDir > -6) Then
XDir := -6;
If (XDir > 0) And (XDir < 6) Then
XDir := 6;
If (YDir <= 0) And (YDir > -6) Then
YDir := -6;
If (YDir > 0) And (YDir < 6) Then
YDir := 5;
XDir := Max(-20, Min(20, XDir));
YDir := Max(-20, Min(20, YDir));
DrawIcon(DC, OX, OY, Erase);
DrawIcon(DC, X, Y, Ball);
ReleaseDC(Wnd, DC);
Until (YieldThread = tm_Quit);
ExitThread;
End;
{ ***** Window function ***** }
Function MainWndProc(Window : HWnd; Msg, wParam : Word; lParam : LongInt) : LongInt; Export;
Var
Title : Array [0..255] Of Char;
NumThreads : LongInt;
Begin
Case Msg Of
wm_Create : Begin
LineProc := MakeProcInstance(@LineThread, HInstance);
BallProc := MakeProcInstance(@BallThread, HInstance);
End;
wm_Command : Case wParam Of
100 : Begin
StartThread(BallProc, 2000, Window, 30, 10);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;
110 : Begin
SetThreadPriority(StartThread(LineProc, 2000, Window, 0, 0), ts_DefPriority Div 2);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;
500 : InvalidateRect(Window, Nil,TRUE);
510 : Begin
EndTaskThreads(GetCurrentTask);
InvalidateRect(Window, Nil,TRUE);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;
End;
wm_Destroy : Begin
EndTaskThreads(GetCurrentTask);
FreeProcInstance(BallProc);
FreeProcInstance(LineProc);
PostQuitMessage(0);
End;
Else
MainWndProc := DefWindowProc(Window, Msg, wParam, lParam);
End;
End; {MainWndProc}
Const
WindowClass : TWndClass = (Style : cs_HRedraw + cs_VRedraw;
lpfnWndProc : Nil;
cbClsExtra : 0;
cbWndExtra : 0;
hInstance : 0;
hIcon : 0;
hCursor : 0;
hbrBackground : 0;
lpszMenuName : 'APPMENU';
lpszClassName : ClassName);
Begin
RandSeed := MakeLong(((GetCurrentTime SHR 16) SHL 16), ((GetCurrentTime SHR 16) SHL 16));
If (HPrevInst = 0) Then
Begin
WindowClass.lpfnWndProc := @MainWndProc;
WindowClass.hInstance := HInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(white_Brush);
If Not RegisterClass(WindowClass) Then
Begin
MessageBox(0, 'Unable to register window class.', Nil, mb_Ok Or mb_IconStop);
Halt;
End;
End;
Wnd := CreateWindow(ClassName, AppName + ' - 0 Threads', ws_OverlappedWindow,
cw_UseDefault, 0, cw_UseDefault, 0, 0, 0, HInstance, Nil);
If (Wnd <> 0) Then
Begin
ShowWindow(Wnd, sw_ShowNorm